perm filename CAREYE.SAI[GEO,BGB]1 blob
sn#001351 filedate 1972-10-28 generic text, type T, neo UTF8
00100 BEGIN "CAREYE-3 - CART'S EYE THREE - AUGUST 1972"
00200
00300 REQUIRE "ABBREV[SYS,BGB]" SOURCE_FILE;
00400 REQUIRE "DPYIII[SYS,BGB]" SOURCE_FILE;
00500 REQUIRE "SAITRG[SYS,BGB]" SOURCE_FILE;
00600
00700 α TELETYPE COMMAND STATE;
00800 ITG CHR,CTRL,META,LETT,αβ,BRK,FLG;
00900 STRING STR;
01000
01100 α DEFINITIONS;
01200
01300 DEFINE mm = "3.2808@-3";
01400 DEFINE PPIOT="'702000000000";
01500 DEFINE THRICE="FOR I←1 STEP 1 UNTIL 3 DO";
01600 DEFINE PUSH= "PADPDL[PDLPTR←PDLPTR+1]";
01700 DEFINE POP = "PADPDL[1+(PDLPTR←PDLPTR-1)]";
01800 DEFINE TOP = "PADPDL[PDLPTR]";
01900 DEFINE ARG1= "PADPDL[PDLPTR-1]";
02000 DEFINE ARG2= "PADPDL[PDLPTR-2]";
02100 DEFINE INCREM(I)="I←I+1";
02200 DEFINE DECREM(I)="I←I-1";
02300 DEFINE XSUBR="EXTERNAL SIMPLE PROCEDURE";
02400
02500 INTERNAL ITG ARRAY PADPDL[0:1000];
02600 INTERNAL ITG PDLPTR,CUT,DEL;
02700
02800 INTERNAL SAFE ITG ARRAY HEADER[0:9];
02900 INTERNAL SAFE ITG ARRAY TVBUF [0:10367];
03000
03100 INTERNAL SAFE ITG ARRAY PAC [0:1727];
03200 SAFE ITG ARRAY DPYBUF[1:5000];
03300 SAFE ITG ARRAY HISTO[-1:64];
03400
03500 α SOURCE WINDOW CENTER;
03600 ITG SX,SY;
03700 REAL SOX,SOY;
03800 α OBJECT WINDOW;
03900 REAL OX,OY,MAG;
04000 α PSEUDO BEAM POSITION;
04100 REAL XXX,YYY;
04200 EXTERNAL SUBR CLIPIN (REAL XL,XH,YL,YH);
04300 EXTERNAL BOOLEAN SUBR CLIP (REFERENCE REAL X1,Y1,X2,Y2);
00100 α ABBREVIATIONS FOR PROCEDURE DECLARATIONS;
00200 DEFINE XISUBR= "EXTERNAL INTEGER SIMPLE PROCEDURE";
00300 DEFINE XRSUBR= "EXTERNAL REAL SIMPLE PROCEDURE";
00400 DEFINE XSUBR = "EXTERNAL SIMPLE PROCEDURE";
00500 DEFINE ISUBR = "INTEGER SIMPLE PROCEDURE";
00600 DEFINE RSUBR = "REAL SIMPLE PROCEDURE";
00700 DEFINE BSUBR = "BOOLEAN SIMPLE PROCEDURE";
00800
00900 α YE OLDE MNEMONICS;
01000 ISUBR LAC (ITG Q); START_CODE MOVE 1,@Q END;
01100 RSUBR LACR(ITG Q); START_CODE MOVE 1,@Q END;
01200 ISUBR CAR (ITG Q); START_CODE HLRZ 1,@Q END;
01300 ISUBR CDR (ITG Q); START_CODE HRRZ 1,@Q END;
01400 SUBR DAC (ITG N,Q); START_CODE MOVE N; MOVEM @Q END;
01500 SUBR DACR(REAL X;ITG Q);START_CODE MOVE X;MOVEM @Q END;
01600 SUBR DIP (ITG N,Q); START_CODE MOVE N; HRLM @Q END;
01700 SUBR DAP (ITG N,Q); START_CODE MOVE N; HRRM @Q END;
01800 ISUBR NIP (ITG Q); START_CODE HLRE 1,@Q END;
01900 ISUBR NAP (ITG Q); START_CODE HRRE 1,@Q END;
02000 DEFINE INCREM(A)="A←A+1";
02100 DEFINE DECREM(A)="A←A-1";
02200
02300 α FATAL MESSAGE;
02400 SUBR FATAL (STRING S);
02500 ⊂ OUTSTR(↓&"FATAL ERROR - "&S&↓);
02600 WHILE TRUE DO INCHRW ⊃;
02700 α UBFEV NUMBER;
02800 ISUBR ITYPE (ITG X);
02900 RETURN(CASE(CAR(X)LAND '17)OF
03000 (0,1,2,0, 3,0,0,0, 4,0,0,0, 0,0,0,0));
03100 α ENTITY TYPES;
03200 BSUBR BTYPE(ITG X); RETURN((CAR(X)LAND 1)≠0);
03300 BSUBR FTYPE(ITG X); RETURN((CAR(X)LAND 2)≠0);
03400 BSUBR ETYPE(ITG X); RETURN((CAR(X)LAND 4)≠0);
03500 BSUBR VTYPE(ITG X); RETURN((CAR(X)LAND 8)≠0);
03600 α WORLD CONTEXT;
03700 EXTERNAL ITG WORLD,BTOTAL,FTOTAL,ETOTAL,VTOTAL;
00100 SUBR INITIALIZATION;
00200 BEGIN
00300 S⊂ PPIOT 2,-300;PPIOT 3,'2002;⊃;
00400 ⊂ ITG I;FOR I←1 TO 20 DO OUTSTR(↓);⊃;
00500 OUTCHR("o");
00600 END;
00100 SUBR AI(REAL X,Y);⊂ XXX←X*MAG+SOX;YYY←Y*MAG+SOY;⊃;
00200 SUBR AV(REAL X,Y);
00300 BEGIN
00400 REAL X1,Y1,X2,Y2;
00500 X1←XXX;Y1←YYY;X2←XXX←X*MAG+SOX;Y2←YYY←Y*MAG+SOY;
00600 IF CLIP(X1,Y1,X2,Y2) THEN
00700 ⊂ AIVECT(X1,Y1);AVECT(X2,Y2);⊃;
00800 END;
00900
01000 SUBR CROP;
01100 BEGIN "CROP"
01200 REAL OXL,OXH,OYL,OYH;
01300 SOX ← OX - SX*MAG;
01400 SOY ← OY - SY*MAG;
01500 OXL ← (OX - MAG*150*64) MAX -500;
01600 OXH ← (OX + MAG*150*64) MIN 500;
01700 OYL ← (OY - MAG*115*64) MAX -450;
01800 OYH ← (OY + MAG*115*64) MIN 450;
01900 CLIPIN(OXL,OXH,OYL,OYH);
02000 END;
00100 α INPUT A TELEVISION PICTURE;
00200 INTERNAL SUBR TVIN (STRING S);
00300 BEGIN "TVIN"
00400 STRING STR;ITG FLG; LABEL L1,L2;
00500 OPEN(1,"DSK",8,3,0,0,0,0);
00600 STR←S;IF FLG←(LENGTH(STR)=0) THEN GO L2;
00700 L1: LOOKUP(1,STR,FLG);
00800 IF FLG THEN LOOKUP(1,STR&".TMP[DAT,BGB]",FLG);
00900 L2: IF FLG THEN ⊂ OUTSTR(9&"TV FILE = ");
01000 STR←INCHWL;IF LENGTH(STR)=0 THEN RETURN;GO L1;⊃;
01100 ARRYIN(1,HEADER[0],10);
01200 ARRYIN(1,TVBUF[0],10368);
01300 RELEASE(1);
01400 END "TVIN";
00100 ITG X0,Y0,X,Y,I,RC,R,C;
00200 ITG CNT,BUF;
00300 EXTERNAL SUBR PACXOR;
00400 EXTERNAL ITG SUBR MKVIC;
00100 SUBR DPYPGON(ITG P);
00200 BEGIN "DPYPGON"
00300 ITG X,Y,E,E0,V;
00400
00500 SUBR GETXY(ITG V);
00600 BEGIN "GETXY"
00700 RC←LAC(V-1);
00800 R←RC LSH-18; C←RC LAND '777777;
00900 Y←(108*64-R)*MAG; X←(C-144*64)*MAG;
01000 END "GETXY";
01100
01200 E←E0←CAR(P+1);V←CAR(E+1);GETXY(V);AI(X,Y);
01300 DO ⊂ V←CDR(E+1);GETXY(V);AV(X,Y); ⊃ UNTIL (E←CDR(V+1))=E0;
01400 END "DPYPGON";
01500
01600 SUBR REFRESH;
01700 BEGIN "REFRESH"
01800 ITG P,E,E0,V,I,CNT;
01900 DPYSET(DPYBUF);AIVECT(-500,-450);AVECT(+500,-450);
02000 AVECT(+500,+450);AVECT(-500,+450);AVECT(-500,-450);
02100 AIVECT(-100,400);DPYBIG(3);DPYSST("CUT = "&CVS(CUT));
02200 FOR I←1 TO PDLPTR DO
02300 BEGIN LABEL L1;
02400 P ← PADPDL[I];
02500 DPYPGON(P);
02600 END;
02700 DPYBIG(1);AIVECT(-511,430);
02800 FOR I←PDLPTR STEP -1 UNTIL (1 MAX (PDLPTR-20)) DO
02900 DPYSST("P"&CVS(PADPDL[I])&↓);
03000 DPYOUT(0);
03100 END "REFRESH";
00100 INTERNAL SUBR MKVICI;
00200 BEGIN "MKVICI"
00300 XISUBR MKPAP; XSUBR SMOOTH(ITG V1,V2;REAL X);
00400 XSUBR KLPGON(ITG I);
00500 ITG P1,P2,V1,V2,E,CHR; LABEL L;
00600 SX←SY←0;
00700 MAG ← 7/32; DEL ←32*64;
00800 CROP;
00900 PACXOR;
01000 WHILE (P1←MKVIC)≠0 DO
01100 BEGIN
01200 CNT ← ABS(LAC(P1-1));
01300 IF CNT≤10 THEN ⊂ KLPGON(P1);CONTINUE;⊃;
01400 α POSSIBLE PRE-SMOOTH DISPLAY;
01500 IF CTRL THEN ⊂ DPYSET(DPYBUF);DPYPGON(P1);DPYOUT(1);
01600 PUSH←P1;RETURN;⊃;
01700 α AD HOC SMOOTH CALLING;
01800 P2 ← MKPAP;
01900 E ← CAR(P2+1); V1 ← CAR(E+1); V2 ← CDR(E+1);
02000 SMOOTH(V1,V2,0.5); SMOOTH(V2,V1,0.5);
02100 KLPGON(P1);
02200 PUSH ← P2;
02300 END;
02400 REFRESH;
02500 END "MKVICI";
02600
02700 XSUBR THRESH(ITG CUT);
02800 SUBR MKIMAGE;
02900 BEGIN "MKIMAGE"
03000 ITG I;
03100 FOR I←8 STEP 5 UNTIL 60 DO
03200 ⊂ THRESH(I);MKVICI; ⊃;
03300 END "MKIMAGE";
00100 INTERNAL SUBR PLOT;
00200 BEGIN
00300 STRING FILNAM;
00400 INTEGER FLG,CHN;
00500 CHN ← GETCHAN;
00600 OPEN(CHN,"DSK",8,0,3,0,0,0);
00700 DO BEGIN
00800 OUTSTR(13&10&"PLOT FILE = ");
00900 FILNAM ← INCHWL;
01000 ENTER(CHN,FILNAM&".PLT",FLG);
01100 END UNTIL ¬FLG;
01200 ARRYOUT(CHN,DPYBUF[1],DPYBUF[2]);
01300 RELEASE(CHN);
01400 END;
00100 ITG SUBR PIXPTR (ITG ROW,COL);
00200 BEGIN "PIXPTR"
00300 RETURN(POINT(6,
00400 TVBUF[(ROW*48)+(COL DIV 6)],6*(COL MOD 6)-1));
00500 END "PIXPTR";
00600
00700 SUBR HISTOGRAM;
00800 BEGIN "HISTOGRAM"
00900 ITG Q,I,PTR;
01000 HISTO[-1]←0;ARRBLT(HISTO[0],HISTO[-1],64);
01100 PTR ← PIXPTR(0,0);
01200 FOR I←0 TO 62207 DO
01300 ⊂ Q←ILDB(PTR);INCREM(HISTO[Q]);⊃;
01400 END "HISTOGRAM";
01500
01600 PROCEDURE DPYHISTO;
01700 BEGIN "DPYHISTO"
01800 ITG X,Y;
01900 REAL SX,SY; ITG QMAX,Q,I;
02000 ITG ARRAY DPYBUF[0:300];
02100 DPYSET(DPYBUF);DPYBIG(1);
02200 QMAX ← 0;
02300 FOR I←0 TO 63 DO QMAX ← QMAX MAX HISTO[I];
02400 SY ← 800/QMAX;
02500 SX ← 1024/64;
02600 AIVECT(511,-400);AVECT(-511,-400);
02700 FOR I←0 TO 63 DO
02800 ⊂ Q←HISTO[I];X←I*SX-512;Y←Q*SY-400;
02900 AVECT(X,Y);
03000 IF (I LAND 1) THEN
03100 ⊂ AIVECT(X-8,Y);DPYSST(CVS(I));AIVECT(X,Y);⊃;
03200 AVECT(X+SX,Y);⊃;
03300 AVECT(511,-400);
03400 DPYOUT(6);
03500 HYDPOG(1);HYDPOG(2);HYDPOG(3);HYDPOG(4);
03600 INCHRW;HYDPOG(6);
03700 END "DPYHISTO";
00100 SUBR OUTPGN;
00200 BEGIN "OUTPGN"
00300 ITG X,Y,E,E0,V,P,ECNT;
00400
00500 SUBR GETXY(ITG V);
00600 BEGIN "GETXY"
00700 RC←LAC(V-1);
00800 R←RC LSH-18; C←RC LAND '777777;
00900 Y←(108*64-R)*MAG; X←(C-144*64)*MAG;
01000 END "GETXY";
01100
01200 P ← PADPDL[1];
01300 OPEN(2,"DSK",8,0,3,0,0,0);
01400 ENTER(2,"O.JEG",0);
01500 WORDOUT(2,1);
01600 WORDOUT(2,CUT);
01700
01800 ECNT←0;
01900 E←E0←CAR(P+1);V←CAR(E+1);
02000 DO ⊂ V←CDR(E+1);ECNT←ECNT+1; ⊃ UNTIL (E←CDR(V+1))=E0;
02100 WORDOUT(2,ECNT);
02200 OUTSTR(9&"ECNT = "&CVS(ECNT)&↓);
02300
02400 E←E0←CAR(P+1);V←CAR(E+1);
02500 DO ⊂ V←CDR(E+1);GETXY(V);
02600 WORDOUT(2,X);WORDOUT(2,Y); ⊃ UNTIL (E←CDR(V+1))=E0;
02700 OUTSTR(9&"EOF"&↓);
02800 RELEASE(2);
02900 END;
00100 α CAREYE COMMAND SCANNER - A JUMP TABLE;
00200
00300 INTERNAL PROCEDURE CAREYE;
00400 BEGIN "CAREYE"
00500
00600 OUTSTR(↓&"o");
00700 WHILE TRUE DO
00800 BEGIN "LISTEN"
00900
01000 CHR ← INCHRW;
01100 αβ ← (CHR LSH -7)LAND 3;
01200 CTRL ← CHR LAND '200;
01300 META ← CHR LAND '400;
01400 CHR ← CHR LAND '177;
01500 LETT ← CHR LAND '37;
01600
00100 IF "A"≤CHR ∧ CHR≤"Z" ∨ "a"≤CHR ∧ CHR≤"z" THEN
00200 CASE LETT OF
00300 BEGIN ;
00400 "A" ;
00500 "B" ;
00600 "C" ⊂ STR←INCHWL;CUT←INTSCAN(STR,BRK);THRESH(CUT);OUTSTR("o");⊃;
00700 "D" ;
00800 "E" ;
00900 "F" ;
01000 "G" ;
01100 "H" ⊂ HISTOGRAM;DPYHISTO;⊃;
01200 "I" ⊂ TVIN(INCHWL);OUTSTR("o");⊃;
01300 "J" ;
01400 "K" IF PDLPTR≥1 THEN
01450 ⊂ XSUBR KLPGON(ITG P);KLPGON(POP);REFRESH;OUTSTR("o");⊃;
01500 "L" ;
01600 "M" ⊂ MKVICI;OUTSTR(↓&"o");⊃;
01700 "N" ;
01800 "O" OUTPGN;
01900 "P" PLOT;
02000 "Q" MKIMAGE;
02100 "R" ;
02200 "S" ;
02300 "T" ;
02400 "U" ;
02500 "V" ;
02600 "W" ;
02700 "X" ;
02800 "Z" ;
02900 END;
03000
03100 IF CHR=13 THEN ⊂ OUTSTR("o");CONTINUE;⊃;
03200 IF CHR=":" THEN SX←SX+DEL ELSE
03300 IF CHR=";" THEN SX←SX-DEL ELSE
03400 IF CHR=")" THEN SY←SY+DEL ELSE
03500 IF CHR="(" THEN SY←SY-DEL ELSE
03600 IF CHR="/" THEN DEL←(DEL%2)MAX 1 ELSE
03700 IF CHR="\" THEN DEL←(DEL*2) ELSE
03800 IF CHR="*" THEN MAG←MAG*2 ELSE
03900 IF CHR="-" THEN MAG←MAG/2 ELSE CONTINUE;
04000 CROP;REFRESH;
04100
04200 END "LISTEN";
04300 END "CAREYE";
04400 INITIALIZATION;REFRESH;
04500 CAREYE;
04600
04700 END;